perm filename SYSTEM.F4[COL,LCS] blob
sn#104319 filedate 1974-05-25 generic text, type T, neo UTF8
DIMENSION LNOT(200),PARM(0/8,200),IENV(2,200)
DIMENSION PXYR(3,50),NOTSYS(0/20,50)
COMMON LSYS(50),LPAT(50)
DIMENSION SYSDAT(4,50),IRXY(2,200)
DIMENSION XYSYS(2,20,50),TMPX(20),TMPY(20)
DIMENSION LTMP(20),RXY(4,200),RTIM(3,200)
DIMENSION NOTRUN(200),IRUNS(3,50),MOVRUN(2,200)
DIMENSION ET(11/50),AMPX(11/50),RPARM(16,200),ITY(20)
INTEGER RUNSYS,RUNNOT
CALL RNDINT
TWOPI=2.0*3.1415926535
AFAC=2.0*3.1415926535/360.0
TIME=0.0
BTPAT=0.0
ETPAT=0.0
RUNSYS=0
RUNNOT=1
DIR=1.0
C INPUT FILE FORMAT:
C 'NOTES'
C LAB BT RATE DUR AMP CF MF MI1 MI2 ENV(A3) MI-ENV(A3)
C RANDOM PARMS(IF ANY)
C 'SYS'
C SYS-LAB NUM-SET LAB1 X Y LAB2 X Y ETC.
C 'PATHS'
C PATH-LAB TYPE X Y RAD
C 'RUN' RANDOM-SEED
C NAM OP LAB1 ETC. (SEE BELOW)
C 'END'
C
C VARIOUS RUN COMMANDS:
C OBS MOVE PA1(A3) PA2 DUR
C OBS INIT PA1 DUR
C OBS STAY PA2 DUR
C SYS MOVE SY1 SY2 TIME1 TIME2
C SYS INIT SY1 TIME
C SYS STOP SY2 TIME
C SPD MOVE VAL TIME1 TIME2
C TYP TIME N(*A5) MESSAGE-WITH SPACES(MULT OF A5)
C REV INIT VAL TIME
C DIS INIT VAL TIME
C ANG TIME VAL
C MAX TIME VAL
C ROT INIT SYS VAL TIME
C ROT STOP SYS TIME
C ROT ZERO SYS TIME
TYPE 2000
2000 FORMAT(' SAVE FILE : '$)
ACCEPT 101,JFNAM
IF(JFNAM.EQ.' ')GO TO 199
CALL IFILE(1,JFNAM)
TYPE 105
ACCEPT 101,IFNAM
CALL OFILE(20,IFNAM)
WRITE(20,106)
IGOUT=1
TYPE 2006
ACCEPT 2001,IRV
WRITE(20,2007)IRV
2001 FORMAT(I)
2002 FORMAT(A5,7F)
2003 FORMAT(2A5,3F)
2004 FORMAT(A5,7F10.3)
2005 FORMAT(2A5,3F10.3,' ;PRINT(P1);')
2006 FORMAT(' REVERB : '$)
2007 FORMAT(' REV 0 ',I5,' ;')
DO 2010 I=1,100000
READ(1,2002)NAM,(TMPX(J),J=1,7)
IF(NAM.EQ.' FINI')GO TO 2011
READ(1,2003)LAB1,LAB2,(TMPX(J),J=8,10)
TIME=TMPX(1)
WRITE(20,2004)NAM,(TMPX(J),J=1,7)
WRITE(20,2005)LAB1,LAB2,(TMPX(J),J=8,10)
2010 CONTINUE
2011 GO TO 99
99 CALL RELEASE(1)
IF(IGPAT.EQ.0.OR.IGSYS.EQ.0)GO TO 199
IGDIA=1
GO TO 299
199 TYPE 100
100 FORMAT(' INPUT : '$)
ACCEPT 101,JFNAM,IRND
101 FORMAT(A5,I)
CALL IFILE(1,JFNAM)
READ(1,104)LIN,LABX,R
NN=0
IF(LABX.EQ.'NOT')GO TO 1
IF(LABX.EQ.'SYS'.AND.NOTGOT.EQ.1)GO TO 3
IF(LABX.EQ.'PAT'.AND.NOTGOT.EQ.1)GO TO 7
IF(LABX.EQ.'RUN'.AND.IGSYS.EQ.1.AND.IGPAT.EQ.1)GO TO 998
120 FORMAT(' MISSING INPUT ')
TYPE 120
GO TO 99
C READ NOTES UNTIL 'SYS'
1 NN=NN+1
NOTGOT=1
READ(1,102)LIN,LNOT(NN),(PARM(I,NN),I=0,7),IENV(1,NN),
1 IENV(2,NN),PARM(8,NN)
IF(PARM(8,NN).EQ.0.0)PARM(8,NN)=1.0
102 FORMAT(I,A3,8F,A3,A4,F)
IF(LNOT(NN).EQ.'SYS')GO TO 2
IF(LNOT(NN).EQ.'END')GO TO 1002
CALL RNDPRM(NN,RPARM,PARM)
GO TO 1
1002 NNOT=NN-1
GO TO 99
2 NNOT=NN-1
C SYSTEMS UNTIL 'PATHS'
NN=0
3 NN=NN+1
IGSYS=1
103 FORMAT(I,A3,I,2F)
READ(1,103)LIN,LSYS(NN),II,SYSDAT(1,NN),SYSDAT(2,NN)
NOTSYS(0,NN)=II
ISAV=0
133 FORMAT(I,4(A3,F,F))
134 IF(II.LE.4)GO TO 135
READ(1,133)LIN,
1 ((LTMP(I+ISAV),TMPX(I+ISAV),TMPY(I+ISAV)),I=1,4)
ISAV=ISAV+4
II=II-4
GO TO 134
135 IF(LSYS(NN).EQ.'PAT')GO TO 6
IF(LSYS(NN).EQ.'END')GO TO 1006
READ(1,133)LIN,
1 ((LTMP(I+ISAV),TMPX(I+ISAV),TMPY(I+ISAV)),I=1,II)
DO 5 I=1,NOTSYS(0,NN)
DO 4 J=1,NNOT
IF(LTMP(I).EQ.LNOT(J))NOTSYS(I,NN)=J
4 CONTINUE
XX=TMPX(I)-SYSDAT(1,NN)
YY=TMPY(I)-SYSDAT(2,NN)
A=ATAN(XX/YY)
IF(YY.LT.0.0)A=A+180.*AFAC
IF(YY.GE.0.0.AND.XX.LT.0.0)A=A+TWOPI
XYSYS(1,I,NN)=SQRT(XX**2+YY**2)
XYSYS(2,I,NN)=A
5 CONTINUE
GO TO 3
1006 NSYS=NN-1
GO TO 99
6 NSYS=NN-1
C READ PATHS UNTIL 'RUN'
NN=0
7 NN=NN+1
IGPAT=1
READ(1,104)LIN,LPAT(NN),(PXYR(I,NN),I=1,3)
104 FORMAT(I,A3,3F)
1004 FORMAT(I,A3,3F,A3,A1,A3)
IF (LPAT(NN).EQ.'RUN')GO TO 9
IF (LPAT(NN).EQ.'END')GO TO 1009
IF(PXYR(3,NN).NE.-1.0)GO TO 7
REREAD 1004,LIN,LPAT(NN),X1,Y1,Z,LAB1,LIN,LAB2
IPAT=IGOTPA(LAB2,NN)
X2=PXYR(1,IPAT)
Y2=PXYR(2,IPAT)
R=PXYR(3,IPAT)
D=SQRT((X1-X2)**2+(Y1-Y2)**2)
IF(LAB1.EQ.'LNK')D=D-R
IF(LAB1.EQ.'LNG')D=D+R
IF(D.LT.0.)D=-D
PXYR(3,NN)=D
GO TO 7
1009 NPAT=NN-1
GO TO 99
998 IF(IRND.EQ.0)IRND=R
GO TO 999
9 NPAT=NN-1
IF(IRND.EQ.0)IRND=PXYR(1,NN)
999 DO 110 I=1,IRND
X=RAND(0.0,1.0)
110 CONTINUE
IF(IGDIA.EQ.1)GO TO 499
299 TYPE 107
107 FORMAT(' DIAGRAM : '$)
108 FORMAT(A1)
ACCEPT 108,ISHOW
IF(ISHOW.NE.'Y'.AND.IGDIA.EQ.1)GO TO 199
IF(ISHOW.NE.'Y'.AND.IGDIA.EQ.0)GO TO 499
IF(IGPLT.EQ.0)CALL PLOTS(K)
IGPLT=1
DO 152 NN=1,NPAT
DO 151 I=0,360
R=I*AFAC
RX=PXYR(1,NN)+SIN(R)*PXYR(3,NN)
RY=PXYR(2,NN)+COS(R)*PXYR(3,NN)
IF(I.EQ.0)CALL PLOT(RX/100.,RY/100.,3)
IF(I.NE.0)CALL PLOT(RX/100.,RY/100.,2)
151 CONTINUE
152 CONTINUE
DO 154 NN=1,NSYS
DO 153 I=1,NOTSYS(0,NN)
II=LNOT(NOTSYS(I,NN))
X=XYSYS(1,I,NN)*SIN(XYSYS(2,I,NN))+SYSDAT(1,NN)
Y=XYSYS(1,I,NN)*COS(XYSYS(2,I,NN))+SYSDAT(2,NN)
CALL SYMBOL(X/100.,Y/100.,.16,II,0,3)
CALL SYMBOL(X/100.,Y/100.,.16,II,0,3)
153 CONTINUE
154 CONTINUE
IF(IGDIA.EQ.1)GO TO 199
499 IF(IGOUT.EQ.1)GO TO 2012
TYPE 105
105 FORMAT(' OUTPUT FILE :'$)
ACCEPT 101,IFNAM
CALL OFILE(20,IFNAM)
WRITE(20,106)
106 FORMAT(' PLAY;'/)
109 FORMAT(' SHOW RUN :'$)
2012 TYPE 109
ACCEPT 108,IRSHOW
IF(IRSHOW.EQ.'Y')IRSHOW=1
IF(IGPLT.EQ.0.AND.IRSHOW.EQ.1)CALL PLOTS(K)
C READ A PATH
CALL SCAN(NAM,IOP,LAB1,LAB2,VAL,TIM1,TIM2)
10 IF(NAM.EQ.'END')GO TO 1000
IF(IOP.EQ.'INIT'.AND.BTPAT.NE.0.0)GO TO 15
BTPAT=TIME
ETPAT=TIME+TIM2
IPAT=IGOTPA(LAB1,NPAT)
PATX=PXYR(1,IPAT)
PATY=PXYR(2,IPAT)
PATR=PXYR(3,IPAT)
JPAT=0
IF(IOP.NE.'MOVE')GO TO 20
JPAT=IGOTPA(LAB2,NPAT)
PATDX=PXYR(1,JPAT)-PATX
PATDY=PXYR(2,JPAT)-PATY
PATDR=PXYR(3,JPAT)-PATR
GO TO 20
C INIT A PATH BY LEAPING
15 IF(ISETUP)GO TO 18
ISETUP=-1
IPAT=IGOTPA(LAB1,NPAT)
PATNX=PXYR(1,IPAT)
PATNY=PXYR(2,IPAT)
XX=PATNX-PX
YY=PATNY-PY
PATNR=PXYR(3,IPAT)
ANGX=ATAN(XX/YY)
IF(YY.LT.0.0)ANGX=ANGX+180.*AFAC
IF(YY.GE.0.0.AND.XX.LT.0.0)ANGX=ANGX+TWOPI
D=SQRT(XX**2+YY**2)
IF(D.GE.PR+PATNR)GO TO 16
IF(PR.LT.PATNR)ANGX=ANGX-180.*AFAC
IF(ANGX.LT.0.0)ANGX=ANGX+TWOPI
DIRNX=DIR
ANGNX=ANGX
GO TO 17
16 DIRNX=-DIR
ANGNX=ANGX-180.*AFAC
IF(ANGNX.LT.0.0)ANGNX=ANGNX+TWOPI
17 ANGY=ANG
IF(DIR.EQ.1.0)GO TO 175
IF(ANGY.LT.ANGX)ANGY=ANGY+TWOPI
DT=(ANGY-ANGX)/SPDX
GO TO 176
175 IF(ANGX.LT.ANGY)ANGY=ANGY-TWOPI
DT=(ANGX-ANGY)/SPDX
176 ETPAT=ETPAT+DT-.001
GO TO 30
18 ISETUP=0
PATX=PATNX
PATY=PATNY
PATR=PATNR
DIR=DIRNX
ANG=ANGNX+SPDX*(TIME-ETPAT)*DIR
BTPAT=TIME
ETPAT=TIME+TIM2
JPAT=0
GO TO 20
20 CALL SCAN(NAM,IOP,LAB1,LAB2,VAL,TIM1,TIM2)
IF(TIM1.GT.TIME-BTPAT)GO TO 30
21 IF(NAM.EQ.'REV')GO TO 215
IF(NAM.EQ.'SPD')GO TO 220
IF(NAM.EQ.'DIS')GO TO 230
IF(NAM.EQ.'SYS')GO TO 240
IF(NAM.EQ.'TYP'.AND.IGOUT.EQ.0)GO TO 206
IF(NAM.EQ.'CUT')GO TO 209
IF(NAM.EQ.'ANG')GO TO 210
IF(NAM.EQ.'MAX')GO TO 211
IF(NAM.EQ.'ROT')GO TO 212
TYPE 205,NAM
205 FORMAT(' UNRECOGNIZED NAME: ',A3)
GO TO 20
206 REREAD 207,LIN,LAB,R,IYT,(ITY(IY),IY=1,IYT)
WRITE(20,208)(ITY(IY),IY=1,IYT)
207 FORMAT(I,A3,F,I,20A5)
208 FORMAT(20A5)
GO TO 20
209 CUTIME=TIM1+BTPAT
TYPE 105
ACCEPT 101,KFNAM
CALL OFILE(21,KFNAM)
GO TO 20
210 ANG=VAL
GO TO 20
211 ABSMAX=VAL
GO TO 20
212 DO 213 I=1,NSYS
IF(LAB1.EQ.LSYS(I))KKK=I
213 CONTINUE
IF(IOP.EQ.'STOP'.OR.IOP.EQ.'ZERO')SYSDAT(3,KKK)=0.0
IF(IOP.EQ.'INIT')SYSDAT(3,KKK)=VAL
IF(IOP.EQ.'ZERO')SYSDAT(4,KKK)=0.0
GO TO 20
215 BTREV=TIME
ETREV=BTPAT+TIM2
IF(ETREV.LE.BTREV)ETREV=BTREV+1.0
IF(IOP.EQ.'MOVE')GO TO 216
REV=VAL
REVX=VAL
REV2=0.
GO TO 20
216 REV2=VAL-REV
GO TO 20
220 BTSPD=TIME
ETSPD=BTPAT+TIM2
IF(ETSPD.LE.BTSPD)ETSPD=BTSPD+1.0
IF(IOP.EQ.'MOVE')GO TO 221
SPD=VAL
SPDX=VAL
SPD2=0.
GO TO 20
221 SPD2=VAL-SPD
GO TO 20
230 BTDIS=TIME
ETDIS=BTPAT+TIM2
IF(ETDIS.LE.BTDIS)ETDIS=BTDIS+1.0
IF(IOP.EQ.'MOVE')GO TO 231
DIS=VAL
DISX=VAL
DIS2=0.
GO TO 20
231 DIS2=VAL-DIS
GO TO 20
C INIT A SYS
240 ISYS=IGOTSY(LAB1,NSYS)
INUM=NOTSYS(0,ISYS)
IF(IOP.NE.'INIT')GO TO 242
RUNSYS=RUNSYS+1
IRUNS(1,RUNSYS)=ISYS
IRUNS(2,RUNSYS)=RUNNOT
IRUNS(3,RUNSYS)=INUM
DO 241 I=1,INUM
II=RUNNOT+I-1
NOTRUN(II)=NOTSYS(I,ISYS)
RXY(1,II)=XYSYS(1,I,ISYS)
RXY(2,II)=XYSYS(2,I,ISYS)
RXY(3,II)=0.0
RXY(4,II)=0.0
IRXY(1,II)=ISYS
IRXY(2,II)=0
RTIM(1,II)=TIME+PARM(0,NOTRUN(II))
RTIM(2,II)=TIME
RTIM(3,II)=BTPAT+TIM2
MOVRUN(1,II)=0
241 CONTINUE
RUNNOT=RUNNOT+INUM
GO TO 20
C MOVE A SYSTEM OR STOP A SYSTEM
242 DO 243 I=1,RUNSYS
IF(ISYS.EQ.IRUNS(1,I))JJ=I
243 CONTINUE
IRUN=IRUNS(2,JJ)
INUM=IRUNS(3,JJ)
IF(IOP.NE.'MOVE')GO TO 250
DO 247 I=1,INUM
I1=IRUN+I-1
I2=RUNNOT+I-1
NOTRUN(I2)=NOTRUN(I1)
DO 244 J=1,4
RXY(J,I2)=RXY(J,I1)
244 CONTINUE
DO 245 J=1,3
RTIM(J,I2)=RTIM(J,I1)
245 CONTINUE
MOVRUN(1,I2)=MOVRUN(1,I1)
MOVRUN(2,I2)=MOVRUN(2,I1)
IRXY(1,I2)=IRXY(1,I1)
IRXY(2,I2)=IRXY(2,I1)
247 CONTINUE
JSYS=IGOTSY(LAB2,NSYS)
JNUM=NOTSYS(0,JSYS)
JADD=0
IF(JNUM.GT.INUM)JADD=JNUM-INUM
RUNSYS=RUNSYS+1
IRUNS(1,RUNSYS)=JSYS
IRUNS(2,RUNSYS)=RUNNOT
IRUNS(3,RUNSYS)=INUM+JADD
RUNNOT=RUNNOT+INUM+JADD
C REMOVE SYS STOPPED DATA
250 DO 254 I=IRUN,RUNNOT
NOTRUN(I)=NOTRUN(I+INUM)
DO 251 J=1,4
RXY(J,I)=RXY(J,I+INUM)
251 CONTINUE
DO 252 J=1,3
RTIM(J,I)=RTIM(J,I+INUM)
252 CONTINUE
MOVRUN(1,I)=MOVRUN(1,I+INUM)
MOVRUN(2,I)=MOVRUN(2,I+INUM)
IRXY(1,I)=IRXY(1,I+INUM)
IRXY(2,I)=IRXY(2,I+INUM)
254 CONTINUE
DO 255 I=JJ,RUNSYS
IRUNS(1,I)=IRUNS(1,I+1)
IRUNS(2,I)=IRUNS(2,I+1)-INUM
IRUNS(3,I)=IRUNS(3,I+1)
255 CONTINUE
RUNSYS=RUNSYS-1
RUNNOT=RUNNOT-INUM
IF(IOP.NE.'MOVE')GO TO 20
C NOW TO SET UP THE MOVE PARMS
III=JNUM
IF(JNUM.GT.INUM)III=INUM
DO 256 I=1,III
J=RUNNOT-INUM-JADD+I-1
RXY(3,J)=XYSYS(1,I,JSYS)
RXY(4,J)=XYSYS(2,I,JSYS)
IRXY(2,J)=JSYS
RTIM(2,J)=TIME
RTIM(3,J)=BTPAT+TIM2
MOVRUN(1,J)=3
MOVRUN(2,J)=NOTSYS(I,JSYS)
256 CONTINUE
IF(JNUM.EQ.INUM)GO TO 20
IF(JNUM.GT.INUM)GO TO 258
C JNUM<INUM
DO 257 I=III+1,INUM
J=RUNNOT-INUM-JADD+I-1
RTIM(2,J)=TIME
RTIM(3,J)=BTPAT+TIM2
MOVRUN(1,J)=1
257 CONTINUE
GO TO 20
C INUM<JNUM
258 DO 259 I=III+1,JNUM
J=RUNNOT-INUM-JADD+I-1
RXY(1,J)=XYSYS(1,I,JSYS)
RXY(2,J)=XYSYS(2,I,JSYS)
IRXY(1,J)=JSYS
RTIM(1,J)=TIME+PARM(0,NOTSYS(I,JSYS))
RTIM(2,J)=TIME
RTIM(3,J)=BTPAT+TIM2
MOVRUN(1,J)=2
MOVRUN(2,J)=NOTSYS(I,JSYS)
259 CONTINUE
GO TO 20
C INCREMENT TIME REV SPD DIS ANG
30 XTIME=100000.
DO 300 I=1,RUNNOT-1
IF(RTIM(1,I).LT.XTIME)XTIME=RTIM(1,I)
300 CONTINUE
IF(XTIME.GT.ETPAT)GO TO 10
IF(XTIME.GT.TIM1+BTPAT)GO TO 21
DT=XTIME-TIME
TIME=XTIME
TPATX=(TIME-BTPAT)/(ETPAT-BTPAT)
IF(TIME.GE.ETREV)REV2=0.
IF(TIME.GE.ETSPD)SPD2=0.
IF(TIME.GE.ETDIS)DIS2=0.
REVX=REV+REV2*(TIME-BTREV)/(ETREV-BTREV)
SPDX=SPD+SPD2*(TIME-BTSPD)/(ETSPD-BTSPD)
DISX=DIS+DIS2*(TIME-BTDIS)/(ETDIS-BTDIS)
ANG=ANG+DIR*DT*SPDX
ANG=ANORM(ANG)
DO 305 I=1,NSYS
A=SYSDAT(4,I)+DT*SYSDAT(3,I)
A=ANORM(A)
SYSDAT(4,I)=A
305 CONTINUE
C PATH PARMS
IF(JPAT.NE.0)GO TO 301
PX=PATX
PY=PATY
PR=PATR
GO TO 302
301 PX=PATX+PATDX*TPATX
PY=PATY+PATDY*TPATX
PR=PATR+PATDR*TPATX
302 XOBS=PX+SIN(ANG)*PR
YOBS=PY+COS(ANG)*PR
IF(IRSHOW.NE.1)GO TO 303
IF(IRS.EQ.0)CALL PLOT(XOBS/100.,YOBS/100.,3)
IF(IRS.EQ.1)CALL PLOT(XOBS/100.,YOBS/100.,2)
IRS=1
C NOTE PARMS
303 DO 390 I=1,RUNNOT-1
IF(RTIM(1,I).GT.TIME)GO TO 390
J=NOTRUN(I)
IF(MOVRUN(1,I).EQ.2)J=MOVRUN(2,I)
RATE=PRM(1,J,RPARM,PARM)
C MOVING FROM NULL
IF(MOVRUN(1,I).NE.2)GO TO 310
IF(TIME.LT.RTIM(3,I))GO TO 389
MOVRUN(1,I)=0
NOTRUN(I)=MOVRUN(2,I)
MOVRUN(2,I)=0
GO TO 320
310 IF(MOVRUN(1,I).NE.3)GO TO 311
C MOVING COMPLETE SET
IF(TIME.LT.RTIM(3,I))GO TO 320
MOVRUN(1,I)=0
NOTRUN(I)=MOVRUN(2,I)
MOVRUN(2,I)=0
RXY(1,I)=RXY(3,I)
RXY(2,I)=RXY(4,I)
IRXY(1,I)=IRXY(2,I)
IRXY(2,I)=0
GO TO 320
311 IF(MOVRUN(1,I).NE.1)GO TO 320
C MOVING TO NULL
IF(RTIM(3,I).LT.TIME)GO TO 389
C CALCULATE STATIONERY NOTE
320 J=NOTRUN(I)
KSYS=IRXY(1,I)
X=RXY(1,I)*SIN(RXY(2,I)+SYSDAT(4,KSYS))+SYSDAT(1,KSYS)
Y=RXY(1,I)*COS(RXY(2,I)+SYSDAT(4,KSYS))+SYSDAT(2,KSYS)
RATE=PRM(1,J,RPARM,PARM)
DUR=PRM(2,J,RPARM,PARM)
AMP=PRM(3,J,RPARM,PARM)
CF=PRM(4,J,RPARM,PARM)
FM=PRM(5,J,RPARM,PARM)
XMI=PRM(6,J,RPARM,PARM)
YMI=PRM(7,J,RPARM,PARM)
LENV1=IENV(1,J)
LENV2=IENV(2,J)
XPRM=PRM(8,J,RPARM,PARM)
IF(MOVRUN(1,I).NE.3)GO TO 330
C MOVING NOTE
K=MOVRUN(2,I)
MSYS=IRXY(2,I)
X2=RXY(3,I)*SIN(RXY(4,I)+SYSDAT(4,MSYS))+SYSDAT(1,MSYS)
Y2=RXY(3,I)*COS(RXY(4,I)+SYSDAT(4,MSYS))+SYSDAT(2,MSYS)
RATE2=PRM(1,K,RPARM,PARM)
DUR2=PRM(2,K,RPARM,PARM)
AMP2=PRM(3,K,RPARM,PARM)
CF2=PRM(4,K,RPARM,PARM)
FM2=PRM(5,K,RPARM,PARM)
XMI2=PRM(6,K,RPARM,PARM)
YMI2=PRM(7,K,RPARM,PARM)
XPRM2=PRM(8,K,RPARM,PARM)
P=(RTIM(1,I)-RTIM(2,I))/(RTIM(3,I)-RTIM(2,I))
X=X+(X2-X)*P
Y=Y+(Y2-Y)*P
RATE=RATE+(RATE2-RATE)*P
DUR=DUR+(DUR2-DUR)*P
AMP=AMP+(AMP2-AMP)*P
CF=CF+(CF2-CF)*P
FM=FM+(FM2-FM)*P
XMI=XMI+(XMI2-XMI)*P
YMI=YMI+(YMI2-YMI)*P
XPRM=XPRM+(XPRM2-XPRM)*P
C FIGURE NOTE VS. OBSERVER
330 XX=X-XOBS
YY=Y-YOBS
BNGL=ATAN(XX/YY)
IF(YY.LT.0.0)BNGL=BNGL+180.*AFAC
IF(YY.GE.0.0.AND.XX.LT.0.0)BNGL=BNGL+TWOPI
C THE OBSERVER ORIENTS TO THE POINT-CENTER
CNGL=BNGL-ANG
IF(DIR.LT.0.0)CNGL=CNGL+180.*AFAC
331 IF(CNGL.GE.0.0)GO TO 332
CNGL=CNGL+TWOPI
GO TO 331
332 IF(CNGL.LT.TWOPI)GO TO 340
CNGL=CNGL-TWOPI
GO TO 332
340 CHA=(1.0+SIN(CNGL))/2.0
CHB=1.0-CHA
CHA=SQRT(CHA)
CHB=SQRT(CHB)
DIST=SQRT(XX**2+YY**2)
AMP=AMP*(DISX/DIST)
PREV=REVX*(1.+(1.-SQRT(DISX/DIST))/2.)
IF (PREV.LT.0.)PREV=REV*.01
DO 344 JK=11,50
IF (ET(JK).GT.TIME)GO TO 344
ET(JK)=0.0
AMPX(JK)=0.0
344 CONTINUE
DO 345 JK=11,50
IF (ET(JK).EQ.0.0)GO TO 350
345 CONTINUE
TYPE 346
346 FORMAT(' INSTRUMENT OVERFLOW'/)
350 ET(JK)=TIME+DUR
IF(AMP.LE.ABSMAX)GO TO 341
TYPE 342
342 FORMAT(' AMPLITUTE OVERFLOW')
TYPE 351,JK,TIME,DUR,AMP,CF,FM,XMI,YMI
TYPE 352,LENV1,LENV2,PREV,CHA,CHB,XPRM
AMP=ABSMAX
341 AMPX(JK)=AMP
AMPTMP=0
DO 347 JJK=11,50
AMPTMP=AMPTMP+AMPX(JJK)
347 CONTINUE
IF(AMP.LE.AMPMAX)GO TO 348
AMPMAX=AMP
JKSAV=JK
TMESAV=TIME
DURSAV=DUR
CFSAV=CF
FMSAV=FM
XMISAV=XMI
YMISAV=YMI
LN1SAV=LENV1
LN2SAV=LENV2
348 IF(AMPTMP.GT.AMPTOT)AMPTOT=AMPTMP
WRITE(20,351)JK,TIME,DUR,AMP,CF,FM,XMI,YMI
WRITE(20,352)LENV1,LENV2,PREV,CHA,CHB,XPRM
TIMCUT=TIME-CUTIME
IF(CUTIME.NE.0.0.AND.CUTIME.LE.TIME)WRITE(21,351)JK,
1 TIMCUT,DUR,AMP,CF,FM,XMI,YMI
IF(CUTIME.NE.0.0.AND.CUTIME.LE.TIME)WRITE(21,352)LENV1,
1 LENV2,PREV,CHA,CHB,XPRM
351 FORMAT(' FM',I2,' ',7F10.3)
352 FORMAT(2A5,4F10.3,' ;PRINT(P1);')
389 RTIM(1,I)=RTIM(1,I)+RATE
390 CONTINUE
C THE END OF THE WRITE LOOP
GO TO 30
C THIS IS THE LAST STRAW
1000 WRITE(20,1001)
IF(CUTIME.NE.0.0)WRITE(21,1001)
1001 FORMAT(' FINISH;'/)
1003 FORMAT(' MAXAMP = ',F10.0,' MAXTOT = ',F10.0)
TYPE 351,JKSAV,TMESAV,DURSAV,AMPMAX,CFSAV,
1 FMSAV,XMISAV,YMISAV
TYPE 352,LN1SAV,LN2SAV
TYPE 1003,AMPMAX,AMPTOT
CALL EXIT
END
SUBROUTINE RNDPRM(NN,RPARM,PARM)
DIMENSION RPARM(16,30),PARM(0/8,30)
IIRN=0
DO 10 IP=1,8
IF(PARM(IP,NN).GT.9999.0.AND.PARM(IP,NN).LT.20000.0)IIRN=1
10 CONTINUE
IF(IIRN.EQ.0)RETURN
READ(1,11)LIN,(RPARM(IP,NN),IP=1,16)
11 FORMAT(I,16F)
RETURN
END
FUNCTION PRM(IP,NN,RPARM,PARM)
DIMENSION PARM(0/8,30),RPARM(16,30)
PRM=PARM(IP,NN)
IF(PRM.LE.9999.0.OR.PRM.GE.20000.)RETURN
PRM=PRM-9999.00000
PRM=PRM*10
CPRM=1.5
IPP=1
DO 10 II=1,8
IF(PRM.LT.CPRM)GO TO 20
IPP=IPP+1
CPRM=CPRM+1.0
10 CONTINUE
20 IPP=(IPP-1)*2+1
IPP2=IPP+1
PRM=RAND(RPARM(IPP,NN),RPARM(IPP2,NN))
RETURN
END
INTEGER FUNCTION IGOTPA(LAB,NPAT)
COMMON LSYS(50),LPAT(50)
DO 10 IX=1,NPAT
IF(LAB.EQ.LPAT(IX))IGOTPA=IX
10 CONTINUE
RETURN
END
INTEGER FUNCTION IGOTSY(LAB,NSYS)
COMMON LSYS(50),LPAT(50)
DO 10 IX=1,NSYS
IF(LAB.EQ.LSYS(IX))IGOTSY=IX
10 CONTINUE
RETURN
END
SUBROUTINE SCAN(NAM,IOP,LAB1,LAB2,VAL,TIM1,TIM2)
VAL=0.
TIM1=0.
LAB2=0
TIM2=0.
READ (1,1)LIN,NAM,LIN,IOP,VAL,TIM1,TIM2
1 FORMAT(I,A3,A1,A4,3F)
2 FORMAT(I,A3,A1,A4,A1,A3,3F)
3 FORMAT(I,A3,A1,A4,A1,A3,A1,A3,2F)
IF(NAM.EQ.'OBS'.OR.NAM.EQ.'END')GO TO 100
IF(NAM.EQ.'SYS')GO TO 200
IF(NAM.EQ.'CUT'.OR.NAM.EQ.'TYP')GO TO 500
IF(NAM.EQ.'MAX'.OR.NAM.EQ.'ANG')GO TO 500
IF(NAM.EQ.'ROT')GO TO 600
RETURN
100 IF(IOP.EQ.'MOVE')GO TO 300
REREAD 2,LIN,NAM,LIN,IOP,LIN,LAB1,TIM2
TIM1=100000.
RETURN
200 IF(IOP.EQ.'MOVE')GO TO 300
REREAD 2,LIN,NAM,LIN,IOP,LIN,LAB1,TIM1
RETURN
300 REREAD 3,LIN,NAM,LIN,IOP,LIN,LAB1,LIN,LAB2,TIM1,TIM2
IF(NAM.EQ.'OBS')TIM2=TIM1
IF(NAM.EQ.'OBS')TIM1=100000.
RETURN
500 REREAD 501,LIN,NAM,TIM1,VAL
501 FORMAT(I,A3,2F)
RETURN
600 IF(IOP.EQ.'INIT')GO TO 605
REREAD 2,LIN,NAM,LIN,IOP,LIN,LAB1,TIM1
RETURN
605 REREAD 2,LIN,NAM,LIN,IOP,LIN,LAB1,VAL,TIM1
RETURN
END
REAL FUNCTION ANORM(ANGLE)
TWOPI=2.0*3.1415926535
AFAC=2.0*3.1415926535/360.0
305 IF(ANGLE.LT.0.0)ANGLE=ANGLE+TWOPI
IF(ANGLE.LT.0.0)GO TO 305
306 IF(ANGLE.GE.TWOPI)ANGLE=ANGLE-TWOPI
IF(ANGLE.GE.TWOPI)GO TO 306
ANORM=ANGLE
RETURN
END